home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / kcl.lha / c / file.d < prev    next >
Text File  |  1987-06-04  |  39KB  |  1,949 lines
  1. /*
  2. (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  3. Copying of this file is authorized to users who have executed the true and
  4. proper "License Agreement for Kyoto Common LISP" with SIGLISP.
  5. */
  6.  
  7. /*
  8.     file.d
  9.     IMPLEMENTATION-DEPENDENT
  10.  
  11.     The specification of printf may be dependent on the C library,
  12.     especially for read-write access, append access, etc.
  13.     The file also contains the code to reclaim the I/O buffer
  14.     by accessing the FILE structure of C.
  15.     It also contains read_fasl_data.
  16. */
  17.  
  18. #include "include.h"
  19.  
  20. #define    kclgetc(FP)        getc(FP)
  21. #define    kclungetc(C, FP)    ungetc(C, FP)
  22. #define    kclfeof(FP)        feof(FP)
  23. #define    kclputc(C, FP)        putc(C, FP)
  24.  
  25.  
  26. #ifdef BSD
  27. #include <a.out.h>
  28. #endif
  29.  
  30. #ifdef ATT
  31. #include <filehdr.h>
  32. #include <syms.h>
  33. #endif
  34.  
  35. #ifdef E15
  36. #include <a.out.h>
  37. #define exec    bhdr
  38. #define a_text    tsize
  39. #define a_data    dsize
  40. #define a_bss    bsize
  41. #define a_syms    ssize
  42. #define a_trsize    rtsize
  43. #define a_drsize    rdsize
  44. #endif
  45.  
  46.  
  47. static object terminal_io;
  48.  
  49. object Vstandard_input;
  50. object Vstandard_output;
  51. object Verror_output;
  52. object Vquery_io;
  53. object Vdebug_io;
  54. object Vterminal_io;
  55. object Vtrace_output;
  56. object Vverbose;
  57.  
  58. object Kabort;
  59.  
  60. object Kdirection;
  61. object Kinput;
  62. object Koutput;
  63. object Kio;
  64. object Kprobe;
  65. object Kelement_type;
  66. object Kdefault;
  67. object Kif_exists;
  68. object Kerror;
  69. object Knew_version;
  70. object Krename;
  71. object Krename_and_delete;
  72. object Koverwrite;
  73. object Kappend;
  74. object Ksupersede;
  75. object Kif_does_not_exist;
  76. object Kerror;
  77. object Kcreate;
  78.  
  79. object Kprint;
  80. object Kverbose;
  81. object Kif_does_not_exist;
  82. object Kset_default_pathname;
  83.  
  84. object Kstart;
  85. object Kend;
  86.  
  87. object FASL_string;
  88. object LSP_string;
  89.  
  90.  
  91. object siVignore_eof_on_terminal_io;
  92.  
  93. bool
  94. feof1(fp)
  95. FILE *fp;
  96. {
  97.     if (!feof(fp))
  98.         return(FALSE);
  99.     if (fp == terminal_io->sm.sm_object0->sm.sm_fp) {
  100.         if (symbol_value(siVignore_eof_on_terminal_io) == Cnil)
  101.             return(TRUE);
  102. #ifdef UNIX
  103.         fp = freopen("/dev/tty", "r", fp);
  104. #endif
  105. #ifdef AOSVS
  106.  
  107. #endif
  108.         if (fp == NULL)
  109.             error("can't reopen the console");
  110.         return(FALSE);
  111.     }
  112.     return(TRUE);
  113. }
  114.  
  115. #undef    feof
  116. #define    feof    feof1
  117.  
  118.  
  119. end_of_stream(strm)
  120. object strm;
  121. {
  122.     FEerror("Unexpected end of ~S.", 1, strm);
  123. }
  124.  
  125. /*
  126.     Input_stream_p(strm) answers
  127.     if stream strm is an input stream or not.
  128.     It does not check if it really is possible to read
  129.     from the stream,
  130.     but only checks the mode of the stream (sm_mode).
  131. */
  132. bool
  133. input_stream_p(strm)
  134. object strm;
  135. {
  136. BEGIN:
  137.     switch (strm->sm.sm_mode) {
  138.     case smm_input:
  139.         return(TRUE);
  140.  
  141.     case smm_output:
  142.         return(FALSE);
  143.  
  144.     case smm_io:
  145.         return(TRUE);
  146.  
  147.     case smm_probe:
  148.         return(FALSE);
  149.  
  150.     case smm_synonym:
  151.         strm = symbol_value(strm->sm.sm_object0);
  152.         if (type_of(strm) != t_stream)
  153.             FEwrong_type_argument(Sstream, strm);
  154.         goto BEGIN;
  155.  
  156.     case smm_broadcast:
  157.         return(FALSE);
  158.  
  159.     case smm_concatenated:
  160.         return(TRUE);
  161.  
  162.     case smm_two_way:
  163.         return(TRUE);
  164.  
  165.     case smm_echo:
  166.         return(TRUE);
  167.  
  168.     case smm_string_input:
  169.         return(TRUE);
  170.  
  171.     case smm_string_output:
  172.         return(FALSE);
  173.  
  174.     default:
  175.         error("illegal stream mode");
  176.     }
  177. }
  178.  
  179. /*
  180.     Output_stream_p(strm) answers
  181.     if stream strm is an output stream.
  182.     It does not check if it really is possible to write
  183.     to the stream,
  184.     but only checks the mode of the stream (sm_mode).
  185. */
  186. bool
  187. output_stream_p(strm)
  188. object strm;
  189. {
  190. BEGIN:
  191.     switch (strm->sm.sm_mode) {
  192.     case smm_input:
  193.         return(FALSE);
  194.  
  195.     case smm_output:
  196.         return(TRUE);
  197.  
  198.     case smm_io:
  199.         return(TRUE);
  200.  
  201.     case smm_probe:
  202.         return(FALSE);
  203.  
  204.     case smm_synonym:
  205.         strm = symbol_value(strm->sm.sm_object0);
  206.         if (type_of(strm) != t_stream)
  207.             FEwrong_type_argument(Sstream, strm);
  208.         goto BEGIN;
  209.  
  210.     case smm_broadcast:
  211.         return(TRUE);
  212.  
  213.     case smm_concatenated:
  214.         return(FALSE);
  215.  
  216.     case smm_two_way:
  217.         return(TRUE);
  218.  
  219.     case smm_echo:
  220.         return(TRUE);
  221.  
  222.     case smm_string_input:
  223.         return(FALSE);
  224.  
  225.     case smm_string_output:
  226.         return(TRUE);
  227.  
  228.     default:
  229.         error("illegal stream mode");
  230.     }
  231. }
  232.  
  233. object
  234. stream_element_type(strm)
  235. object strm;
  236. {
  237.     object x;
  238.  
  239. BEGIN:
  240.     switch (strm->sm.sm_mode) {
  241.     case smm_input:
  242.     case smm_output:
  243.     case smm_io:
  244.     case smm_probe:
  245.         return(strm->sm.sm_object0);
  246.  
  247.     case smm_synonym:
  248.         strm = symbol_value(strm->sm.sm_object0);
  249.         if (type_of(strm) != t_stream)
  250.             FEwrong_type_argument(Sstream, strm);
  251.         goto BEGIN;
  252.  
  253.     case smm_broadcast:
  254.         x = strm->sm.sm_object0;
  255.         if (endp(x))
  256.             return(Ct);
  257.         return(stream_element_type(x->c.c_car));
  258.  
  259.     case smm_concatenated:
  260.         x = strm->sm.sm_object0;
  261.         if (endp(x))
  262.             return(Ct);
  263.         return(stream_element_type(x->c.c_car));
  264.  
  265.     case smm_two_way:
  266.         return(stream_element_type(strm->sm.sm_object0));
  267.  
  268.     case smm_echo:
  269.         return(stream_element_type(strm->sm.sm_object0));
  270.  
  271.     case smm_string_input:
  272.         return(Sstring_char);
  273.  
  274.     case smm_string_output:
  275.         return(Sstring_char);
  276.  
  277.     default:
  278.         error("illegal stream mode");
  279.     }
  280. }
  281.  
  282. /*
  283.     Open_stream(fn, smm, if_exists, if_does_not_exist)
  284.     opens file fn with mode smm.
  285.     Fn is a namestring.
  286. */
  287. object
  288. open_stream(fn, smm, if_exists, if_does_not_exist)
  289. object fn;
  290. enum smmode smm;
  291. object if_exists, if_does_not_exist;
  292. {
  293.     object x;
  294.     FILE *fp;
  295.     char fname[BUFSIZ];
  296.     int i;
  297.     vs_mark;
  298.  
  299. /*
  300.     if (type_of(fn) != t_string)
  301.         FEwrong_type_argument(Sstring, fn);
  302. */
  303.     if (fn->st.st_fillp > BUFSIZ - 1)
  304.         too_long_file_name(fn);
  305.     for (i = 0;  i < fn->st.st_fillp;  i++)
  306.         fname[i] = fn->st.st_self[i];
  307.     fname[i] = '\0';
  308.     if (smm == smm_input || smm == smm_probe) {
  309.         fp = fopen(fname, "r");
  310.         if (fp == NULL) {
  311.             if (if_does_not_exist == Kerror)
  312.                 cannot_open(fn);
  313.             else if (if_does_not_exist == Kcreate) {
  314.                 fp = fopen(fname, "w");
  315.                 if (fp == NULL)
  316.                     cannot_create(fn);
  317.                 fclose(fp);
  318.                 fp = fopen(fname, "r");
  319.                 if (fp == NULL)
  320.                     cannot_open(fn);
  321.             } else if (if_does_not_exist == Cnil)
  322.                 return(Cnil);
  323.             else
  324.              FEerror("~S is an illegal IF-DOES-NOT-EXIST option.",
  325.                  1, if_does_not_exist);
  326.         }
  327.     } else if (smm == smm_output || smm == smm_io) {
  328.         if (if_exists == Knew_version && if_does_not_exist == Kcreate)
  329.             goto CREATE;
  330.         fp = fopen(fname, "r");
  331.         if (fp != NULL) {
  332.             fclose(fp);
  333.             if (if_exists == Kerror)
  334.                 FEerror("The file ~A already exists.", 1, fn);
  335.             else if (if_exists == Krename) {
  336.                 if (smm == smm_output)
  337.                     fp = backup_fopen(fname, "w");
  338.                 else
  339.                     fp = backup_fopen(fname, "w+");
  340.                 if (fp == NULL)
  341.                     cannot_create(fn);
  342.             } else if (if_exists == Krename_and_delete ||
  343.                    if_exists == Knew_version ||
  344.                    if_exists == Ksupersede) {
  345.                 if (smm == smm_output)
  346.                     fp = fopen(fname, "w");
  347.                 else
  348.                     fp = fopen(fname, "w+");
  349.                 if (fp == NULL)
  350.                     cannot_create(fn);
  351.             } else if (if_exists == Koverwrite) {
  352.                 fp = fopen(fname, "r+");
  353.                 if (fp == NULL)
  354.                     cannot_open(fn);
  355.             } else if (if_exists == Kappend) {
  356.                 if (smm == smm_output)
  357.                     fp = fopen(fname, "a");
  358.                 else
  359.                     fp = fopen(fname, "a+");
  360.                 if (fp == NULL)
  361.                 FEerror("Cannot append to the file ~A.",1,fn);
  362.             } else if (if_exists == Cnil)
  363.                 return(Cnil);
  364.             else
  365.                 FEerror("~S is an illegal IF-EXISTS option.",
  366.                     1, if_exists);
  367.         } else {
  368.             if (if_does_not_exist == Kerror)
  369.                 FEerror("The file ~A does not exist.", 1, fn);
  370.             else if (if_does_not_exist == Kcreate) {
  371.             CREATE:
  372.                 if (smm == smm_output)
  373.                     fp = fopen(fname, "w");
  374.                 else
  375.                     fp = fopen(fname, "w+");
  376.                 if (fp == NULL)
  377.                     cannot_create(fn);
  378.             } else if (if_does_not_exist == Cnil)
  379.                 return(Cnil);
  380.             else
  381.              FEerror("~S is an illegal IF-DOES-NOT-EXIST option.",
  382.                  1, if_does_not_exist);
  383.         }
  384.     } else
  385.         error("illegal stream mode");
  386.     x = alloc_object(t_stream);
  387.     x->sm.sm_mode = (short)smm;
  388.     x->sm.sm_fp = fp;
  389.     fp->_base = BASEFF;
  390.     x->sm.sm_object0 = Sstring_char;
  391.     x->sm.sm_object1 = fn;
  392.     x->sm.sm_int0 = x->sm.sm_int1 = 0;
  393.     vs_push(x);
  394.     setbuf(fp, alloc_contblock(BUFSIZ));
  395.     vs_reset;
  396.     return(x);
  397. }
  398.  
  399. /*
  400.     Close_stream(strm, abort_flag) closes stream strm.
  401.     The abort_flag is not used now.
  402. */
  403. close_stream(strm, abort_flag)
  404. object strm;
  405. bool abort_flag;    /*  Not used now!  */
  406. {
  407.     object x;
  408.  
  409. BEGIN:
  410.     switch (strm->sm.sm_mode) {
  411.     case smm_output:
  412.         if (strm->sm.sm_fp == stdout)
  413.             FEerror("Cannot close the standard output.", 0);
  414.         if (strm->sm.sm_fp == NULL)
  415.             closed_stream(strm);
  416.         fflush(strm->sm.sm_fp);
  417.         insert_contblock((char *)(strm->sm.sm_fp->_base), BUFSIZ);
  418.         strm->sm.sm_fp->_base = NULL;
  419.         fclose(strm->sm.sm_fp);
  420.         strm->sm.sm_fp = NULL;
  421.         break;
  422.  
  423.     case smm_input:
  424.         if (strm->sm.sm_fp == stdin)
  425.             FEerror("Cannot close the standard input.", 0);
  426.  
  427.     case smm_io:
  428.     case smm_probe:
  429.         if (strm->sm.sm_fp == NULL)
  430.             closed_stream(strm);
  431.         insert_contblock((char *)(strm->sm.sm_fp->_base), BUFSIZ);
  432.         strm->sm.sm_fp->_base = NULL;
  433.         fclose(strm->sm.sm_fp);
  434.         strm->sm.sm_fp = NULL;
  435.         break;
  436.  
  437.     case smm_synonym:
  438.         strm = symbol_value(strm->sm.sm_object0);
  439.         if (type_of(strm) != t_stream)
  440.             FEwrong_type_argument(Sstream, strm);
  441.         goto BEGIN;
  442.  
  443.     case smm_broadcast:
  444.         for (x = strm->sm.sm_object0; !endp(x); x = x->c.c_cdr)
  445.             close_stream(x->c.c_car, abort_flag);
  446.         break;
  447.  
  448.     case smm_concatenated:
  449.         for (x = strm->sm.sm_object0; !endp(x); x = x->c.c_cdr)
  450.             close_stream(x->c.c_car, abort_flag);
  451.         break;
  452.  
  453.     case smm_two_way:
  454.         close_stream(strm->sm.sm_object0);
  455.         close_stream(strm->sm.sm_object1);
  456.         break;
  457.  
  458.     case smm_echo:
  459.         close_stream(strm->sm.sm_object0);
  460.         close_stream(strm->sm.sm_object1);
  461.         break;
  462.  
  463.     case smm_string_input:
  464.         break;        /*  There is nothing to do.  */
  465.  
  466.     case smm_string_output:
  467.         break;        /*  There is nothing to do.  */
  468.  
  469.     default:
  470.         error("illegal stream mode");
  471.     }
  472. }
  473.  
  474. object
  475. make_two_way_stream(istrm, ostrm)
  476. object istrm, ostrm;
  477. {
  478.     object strm;
  479.  
  480.     strm = alloc_object(t_stream);
  481.     strm->sm.sm_mode = (short)smm_two_way;
  482.     strm->sm.sm_fp = NULL;
  483.     strm->sm.sm_object0 = istrm;
  484.     strm->sm.sm_object1 = ostrm;
  485.     strm->sm.sm_int0 = strm->sm.sm_int1 = 0;
  486.     return(strm);
  487. }
  488.  
  489. object
  490. make_echo_stream(istrm, ostrm)
  491. object istrm, ostrm;
  492. {
  493.     object strm;
  494.  
  495.     strm = make_two_way_stream(istrm, ostrm);
  496.     strm->sm.sm_mode = (short)smm_echo;
  497.     return(strm);
  498. }
  499.  
  500. object
  501. make_string_input_stream(strng, istart, iend)
  502. object strng;
  503. int istart, iend;
  504. {
  505.     object strm;
  506.  
  507.     strm = alloc_object(t_stream);
  508.     strm->sm.sm_mode = (short)smm_string_input;
  509.     strm->sm.sm_fp = NULL;
  510.     strm->sm.sm_object0 = strng;
  511.     strm->sm.sm_object1 = OBJNULL;
  512.     strm->sm.sm_int0 = istart;
  513.     strm->sm.sm_int1 = iend;
  514.     return(strm);
  515. }
  516.  
  517. object
  518. make_string_output_stream(line_length)
  519. int line_length;
  520. {
  521.     object strng, strm;
  522.     vs_mark;
  523.  
  524.     strng = alloc_object(t_string);
  525.     strng->st.st_hasfillp = TRUE;
  526.     strng->st.st_adjustable = TRUE;
  527.     strng->st.st_displaced = Cnil;
  528.     strng->st.st_dim = line_length;
  529.     strng->st.st_fillp = 0;
  530.     strng->st.st_self = NULL;
  531.         /*  For GBC not to go mad.  */
  532.     vs_push(strng);
  533.         /*  Saving for GBC.  */
  534.     strng->st.st_self = alloc_relblock(line_length);
  535.     strm = alloc_object(t_stream);
  536.     strm->sm.sm_mode = (short)smm_string_output;
  537.     strm->sm.sm_fp = NULL;
  538.     strm->sm.sm_object0 = strng;
  539.     strm->sm.sm_object1 = OBJNULL;
  540.     strm->sm.sm_int0 = strm->sm.sm_int1 = 0;
  541.     vs_reset;
  542.     return(strm);
  543. }
  544.  
  545. object
  546. get_output_stream_string(strm)
  547. object strm;
  548. {
  549.     object strng;
  550.  
  551.     strng = copy_simple_string(strm->sm.sm_object0);
  552.     strm->sm.sm_object0->st.st_fillp = 0;
  553.     return(strng);
  554. }
  555.  
  556. int
  557. readc_stream(strm)
  558. object strm;
  559. {
  560.     int c;
  561.  
  562. BEGIN:
  563.     switch (strm->sm.sm_mode) {
  564.     case smm_input:
  565.     case smm_io:
  566.         if (strm->sm.sm_fp == NULL)
  567.             closed_stream(strm);
  568.         c = kclgetc(strm->sm.sm_fp);
  569.         c &= 0377;
  570.         if (kclfeof(strm->sm.sm_fp))
  571.             end_of_stream(strm);
  572.         strm->sm.sm_int0++;
  573.         return(c);
  574.  
  575.     case smm_synonym:
  576.         strm = symbol_value(strm->sm.sm_object0);
  577.         if (type_of(strm) != t_stream)
  578.             FEwrong_type_argument(Sstream, strm);
  579.         goto BEGIN;
  580.  
  581.     case smm_concatenated:
  582.     CONCATENATED:
  583.         if (endp(strm->sm.sm_object0)) {
  584.             end_of_stream(strm);
  585.         }
  586.         if (stream_at_end(strm->sm.sm_object0->c.c_car)) {
  587.             strm->sm.sm_object0
  588.             = strm->sm.sm_object0->c.c_cdr;
  589.             goto CONCATENATED;
  590.         }
  591.         c = readc_stream(strm->sm.sm_object0->c.c_car);
  592.         return(c);
  593.  
  594.     case smm_two_way:
  595. #ifdef UNIX
  596.         if (strm == terminal_io)                /**/
  597.             flush_stream(terminal_io->sm.sm_object1);    /**/
  598. #endif
  599.         strm->sm.sm_int1 = 0;
  600.         strm = strm->sm.sm_object0;
  601.         goto BEGIN;
  602.  
  603.     case smm_echo:
  604.         c = readc_stream(strm->sm.sm_object0);
  605.         if (strm->sm.sm_int0 == 0)
  606.             writec_stream(c, strm->sm.sm_object1);
  607.         else
  608.             --(strm->sm.sm_int0);
  609.         return(c);
  610.  
  611.     case smm_string_input:
  612.         if (strm->sm.sm_int0 >= strm->sm.sm_int1)
  613.             end_of_stream(strm);
  614.         return(strm->sm.sm_object0->st.st_self
  615.                [strm->sm.sm_int0++]);
  616.  
  617.     case smm_output:
  618.     case smm_probe:
  619.     case smm_broadcast:
  620.     case smm_string_output:
  621.         cannot_read(strm);
  622.  
  623.     default:
  624.         error("illegal stream mode");
  625.     }
  626. }
  627.  
  628. unreadc_stream(c, strm)
  629. int c;
  630. object strm;
  631. {
  632. BEGIN:
  633.     switch (strm->sm.sm_mode) {
  634.     case smm_input:
  635.     case smm_io:
  636.         if (strm->sm.sm_fp == NULL)
  637.             closed_stream(strm);
  638.         kclungetc(c, strm->sm.sm_fp);
  639.         --strm->sm.sm_int0;
  640.         break;
  641.  
  642.     case smm_synonym:
  643.         strm = symbol_value(strm->sm.sm_object0);
  644.         if (type_of(strm) != t_stream)
  645.             FEwrong_type_argument(Sstream, strm);
  646.         goto BEGIN;
  647.  
  648.     case smm_concatenated:
  649.         if (endp(strm->sm.sm_object0))
  650.             goto UNREAD_ERROR;
  651.         strm = strm->sm.sm_object0->c.c_car;
  652.         goto BEGIN;
  653.  
  654.     case smm_two_way:
  655.         strm = strm->sm.sm_object0;
  656.         goto BEGIN;
  657.  
  658.     case smm_echo:
  659.         unreadc_stream(c, strm->sm.sm_object0);
  660.         (strm->sm.sm_int0)++;
  661.         break;
  662.  
  663.     case smm_string_input:
  664.         if (strm->sm.sm_int0 <= 0)
  665.             goto UNREAD_ERROR;
  666.         --strm->sm.sm_int0;
  667.         break;
  668.  
  669.     case smm_output:
  670.     case smm_probe:
  671.     case smm_broadcast:
  672.     case smm_string_output:
  673.         goto UNREAD_ERROR;
  674.  
  675.     default:
  676.         error("illegal stream mode");
  677.     }
  678.     return;
  679.  
  680. UNREAD_ERROR:
  681.     FEerror("Cannot unread the stream ~S.", 1, strm);
  682. }
  683.  
  684. writec_stream(c, strm)
  685. int c;
  686. object strm;
  687. {
  688.     object x;
  689.     char *p;
  690.     int i;
  691.  
  692. BEGIN:
  693.     switch (strm->sm.sm_mode) {
  694.     case smm_output:
  695.     case smm_io:
  696.         strm->sm.sm_int0++;
  697.         if (c == '\n')
  698.             strm->sm.sm_int1 = 0;
  699.         else if (c == '\t')
  700.             strm->sm.sm_int1 = (strm->sm.sm_int1&~07) + 8;
  701.         else
  702.             strm->sm.sm_int1++;
  703.         if (strm->sm.sm_fp == NULL)
  704.             closed_stream(strm);
  705.         kclputc(c, strm->sm.sm_fp);
  706.         break;
  707.  
  708.     case smm_synonym:
  709.         strm = symbol_value(strm->sm.sm_object0);
  710.         if (type_of(strm) != t_stream)
  711.             FEwrong_type_argument(Sstream, strm);
  712.         goto BEGIN;
  713.  
  714.     case smm_broadcast:
  715.         for (x = strm->sm.sm_object0; !endp(x); x = x->c.c_cdr)
  716.             writec_stream(c, x->c.c_car);
  717.         break;
  718.  
  719.     case smm_two_way:
  720.         strm->sm.sm_int0++;
  721.         if (c == '\n')
  722.             strm->sm.sm_int1 = 0;
  723.         else if (c == '\t')
  724.             strm->sm.sm_int1 = (strm->sm.sm_int1&~07) + 8;
  725.         else
  726.             strm->sm.sm_int1++;
  727.         strm = strm->sm.sm_object1;
  728.         goto BEGIN;
  729.  
  730.     case smm_echo:
  731.         strm = strm->sm.sm_object1;
  732.         goto BEGIN;
  733.  
  734.     case smm_string_output:
  735.         strm->sm.sm_int0++;
  736.         if (c == '\n')
  737.             strm->sm.sm_int1 = 0;
  738.         else if (c == '\t')
  739.             strm->sm.sm_int1 = (strm->sm.sm_int1&~07) + 8;
  740.         else
  741.             strm->sm.sm_int1++;
  742.         x = strm->sm.sm_object0;
  743.         if (x->st.st_fillp >= x->st.st_dim) {
  744.             if (!x->st.st_adjustable)
  745.                 FEerror("The string ~S is not adjustable.",
  746.                     1, x);
  747.             p = alloc_relblock(x->st.st_dim * 2 + 16);
  748.             for (i = 0;  i < x->st.st_dim;  i++)
  749.                 p[i] = x->st.st_self[i];
  750.             i = x->st.st_dim * 2 + 16;
  751. #define    ADIMLIM        16*1024*1024
  752.             if (i >= ADIMLIM)
  753.                 FEerror("Can't extend the string.", 0);
  754.             x->st.st_dim = i;
  755.             adjust_displaced(x, p - x->st.st_self);
  756.         }
  757.         x->st.st_self[x->st.st_fillp++] = c;
  758.         break;
  759.  
  760.     case smm_input:
  761.     case smm_probe:
  762.     case smm_concatenated:
  763.     case smm_string_input:
  764.         cannot_write(strm);
  765.  
  766.     default:
  767.         error("illegal stream mode");
  768.     }
  769.     return(c);
  770. }
  771.  
  772. writestr_stream(s, strm)
  773. char *s;
  774. object strm;
  775. {
  776.     while (*s != '\0')
  777.         writec_stream(*s++, strm);
  778. }
  779.  
  780. flush_stream(strm)
  781. object strm;
  782. {
  783.     object x;
  784.  
  785. BEGIN:
  786.     switch (strm->sm.sm_mode) {
  787.     case smm_output:
  788.     case smm_io:
  789.         if (strm->sm.sm_fp == NULL)
  790.             closed_stream(strm);
  791.         fflush(strm->sm.sm_fp);
  792.         break;
  793.  
  794.     case smm_synonym:
  795.         strm = symbol_value(strm->sm.sm_object0);
  796.         if (type_of(strm) != t_stream)
  797.             FEwrong_type_argument(Sstream, strm);
  798.         goto BEGIN;
  799.  
  800.     case smm_broadcast:
  801.         for (x = strm->sm.sm_object0; !endp(x); x = x->c.c_cdr)
  802.             flush_stream(x->c.c_car);
  803.         break;
  804.  
  805.     case smm_two_way:
  806.         strm = strm->sm.sm_object1;
  807.         goto BEGIN;
  808.  
  809.     case smm_echo:
  810.         strm = strm->sm.sm_object1;
  811.         goto BEGIN;
  812.  
  813.     case smm_string_output:
  814.         break;
  815.  
  816.     case smm_input:
  817.     case smm_probe:
  818.     case smm_concatenated:
  819.     case smm_string_input:
  820.         FEerror("Cannot flush the stream ~S.", 1, strm);
  821.  
  822.     default:
  823.         error("illegal stream mode");
  824.     }
  825. }
  826.  
  827. bool
  828. stream_at_end(strm)
  829. object strm;
  830. {
  831.     object x;
  832.     int c;
  833.  
  834. BEGIN:
  835.     switch (strm->sm.sm_mode) {
  836.     case smm_input:
  837.         if (strm->sm.sm_fp == NULL)
  838.             closed_stream(strm);
  839.         c = kclgetc(strm->sm.sm_fp);
  840.         if (kclfeof(strm->sm.sm_fp))
  841.             return(TRUE);
  842.         else {
  843.             kclungetc(c, strm->sm.sm_fp);
  844.             return(FALSE);
  845.         }
  846.  
  847.     case smm_output:
  848.         return(FALSE);
  849.  
  850.     case smm_io:
  851.         return(FALSE);
  852.  
  853.     case smm_probe:
  854.         return(FALSE);
  855.  
  856.     case smm_synonym:
  857.         strm = symbol_value(strm->sm.sm_object0);
  858.         if (type_of(strm) != t_stream)
  859.             FEwrong_type_argument(Sstream, strm);
  860.         goto BEGIN;
  861.  
  862.     case smm_broadcast:
  863.         return(FALSE);
  864.  
  865.     case smm_concatenated:
  866.     CONCATENATED:
  867.         if (endp(strm->sm.sm_object0))
  868.             return(TRUE);
  869.         if (stream_at_end(strm->sm.sm_object0->c.c_car)) {
  870.             strm->sm.sm_object0
  871.             = strm->sm.sm_object0->c.c_cdr;
  872.             goto CONCATENATED;
  873.         } else
  874.             return(FALSE);
  875.  
  876.     case smm_two_way:
  877. #ifdef UNIX
  878.         if (strm == terminal_io)                /**/
  879.             flush_stream(terminal_io->sm.sm_object1);    /**/
  880. #endif
  881.         strm = strm->sm.sm_object0;
  882.         goto BEGIN;
  883.  
  884.     case smm_echo:
  885.         strm = strm->sm.sm_object0;
  886.         goto BEGIN;
  887.  
  888.     case smm_string_input:
  889.         if (strm->sm.sm_int0 >= strm->sm.sm_int1)
  890.             return(TRUE);
  891.         else
  892.             return(FALSE);
  893.  
  894.     case smm_string_output:
  895.         return(FALSE);
  896.  
  897.     default:
  898.         error("illegal stream mode");
  899.     }
  900. }
  901.  
  902. #ifdef BSD
  903. #include <sys/ioctl.h>
  904. #endif
  905.  
  906. bool
  907. listen_stream(strm)
  908. object strm;
  909. {
  910.     object x;
  911.     int c;
  912.  
  913. BEGIN:
  914.     switch (strm->sm.sm_mode) {
  915.     case smm_input:
  916.     case smm_io:
  917. #ifdef BSD
  918.         if (strm->sm.sm_fp == NULL)
  919.             closed_stream(strm);
  920.         if (strm->sm.sm_fp->_cnt > 0)
  921.             return(TRUE);
  922.         c = 0;
  923.         ioctl(strm->sm.sm_fp->_file, FIONREAD, &c);
  924.         if (c > 0)
  925.             return(TRUE);
  926.         else
  927.             return(FALSE);
  928. #else
  929.         c = getc(strm->sm.sm_fp);
  930.         if (feof(strm->sm.sm_fp))
  931.             return(FALSE);
  932.         else {
  933.             ungetc(c, strm->sm.sm_fp);
  934.             return(TRUE);
  935.         }
  936. #endif
  937.  
  938.     case smm_synonym:
  939.         strm = symbol_value(strm->sm.sm_object0);
  940.         if (type_of(strm) != t_stream)
  941.             FEwrong_type_argument(Sstream, strm);
  942.         goto BEGIN;
  943.  
  944.     case smm_concatenated:
  945.     CONCATENATED:
  946.         if (endp(strm->sm.sm_object0))
  947.             return(FALSE);
  948.         strm = strm->sm.sm_object0->c.c_car;    /* Incomplete! */
  949.         goto BEGIN;
  950.  
  951.     case smm_two_way:
  952.     case smm_echo:
  953.         strm = strm->sm.sm_object0;
  954.         goto BEGIN;
  955.  
  956.     case smm_string_input:
  957.         if (strm->sm.sm_int0 < strm->sm.sm_int1)
  958.             return(TRUE);
  959.         else
  960.             return(FALSE);
  961.  
  962.     case smm_output:
  963.     case smm_probe:
  964.     case smm_broadcast:
  965.     case smm_string_output:
  966.         FEerror("Can't listen to ~S.", 1, strm);
  967.  
  968.     default:
  969.         error("illegal stream mode");
  970.     }
  971. }
  972.  
  973. int
  974. file_position(strm)
  975. object strm;
  976. {
  977. BEGIN:
  978.     switch (strm->sm.sm_mode) {
  979.     case smm_input:
  980.     case smm_output:
  981.     case smm_io:
  982.         /*  return(strm->sm.sm_int0);  */
  983.         if (strm->sm.sm_fp == NULL)
  984.             closed_stream(strm);
  985.         return(ftell(strm->sm.sm_fp));
  986.  
  987.     case smm_string_output:
  988.         return(strm->sm.sm_object0->st.st_fillp);
  989.  
  990.     case smm_synonym:
  991.         strm = symbol_value(strm->sm.sm_object0);
  992.         if (type_of(strm) != t_stream)
  993.             FEwrong_type_argument(Sstream, strm);
  994.         goto BEGIN;
  995.  
  996.     case smm_probe:
  997.     case smm_broadcast:
  998.     case smm_concatenated:
  999.     case smm_two_way:
  1000.     case smm_echo:
  1001.     case smm_string_input:
  1002.         return(-1);
  1003.  
  1004.     default:
  1005.         error("illegal stream mode");
  1006.     }
  1007. }
  1008.  
  1009. int
  1010. file_position_set(strm, disp)
  1011. object strm;
  1012. int disp;
  1013. {
  1014. BEGIN:
  1015.     switch (strm->sm.sm_mode) {
  1016.     case smm_input:
  1017.     case smm_output:
  1018.     case smm_io:
  1019.         if (strm->sm.sm_fp == NULL)
  1020.             closed_stream(strm);
  1021.         if (fseek(strm->sm.sm_fp, disp, 0) < 0)
  1022.             return(-1);
  1023.         strm->sm.sm_int0 = disp;
  1024.         return(0);
  1025.  
  1026.     case smm_string_output:
  1027.         if (disp < strm->sm.sm_object0->st.st_fillp) {
  1028.             strm->sm.sm_object0->st.st_fillp = disp;
  1029.             strm->sm.sm_int0 = disp;
  1030.         } else {
  1031.             disp -= strm->sm.sm_object0->st.st_fillp;
  1032.             while (disp-- > 0)
  1033.                 writec_stream(' ', strm);
  1034.         }
  1035.         return(0);
  1036.  
  1037.     case smm_synonym:
  1038.         strm = symbol_value(strm->sm.sm_object0);
  1039.         if (type_of(strm) != t_stream)
  1040.             FEwrong_type_argument(Sstream, strm);
  1041.         goto BEGIN;
  1042.  
  1043.     case smm_probe:
  1044.     case smm_broadcast:
  1045.     case smm_concatenated:
  1046.     case smm_two_way:
  1047.     case smm_echo:
  1048.     case smm_string_input:
  1049.         return(-1);
  1050.  
  1051.     default:
  1052.         error("illegal stream mode");
  1053.     }
  1054. }
  1055.  
  1056. int
  1057. file_length(strm)
  1058. object strm;
  1059. {
  1060. BEGIN:
  1061.     switch (strm->sm.sm_mode) {
  1062.     case smm_input:
  1063.     case smm_output:
  1064.     case smm_io:
  1065.         if (strm->sm.sm_fp == NULL)
  1066.             closed_stream(strm);
  1067.         return(file_len(strm->sm.sm_fp));
  1068.  
  1069.     case smm_synonym:
  1070.         strm = symbol_value(strm->sm.sm_object0);
  1071.         if (type_of(strm) != t_stream)
  1072.             FEwrong_type_argument(Sstream, strm);
  1073.         goto BEGIN;
  1074.  
  1075.     case smm_probe:
  1076.     case smm_broadcast:
  1077.     case smm_concatenated:
  1078.     case smm_two_way:
  1079.     case smm_echo:
  1080.     case smm_string_input:
  1081.     case smm_string_output:
  1082.         return(-1);
  1083.  
  1084.     default:
  1085.         error("illegal stream mode");
  1086.     }
  1087. }
  1088.  
  1089. int
  1090. file_column(strm)
  1091. object strm;
  1092. {
  1093.     int i;
  1094.     object x;
  1095.  
  1096. BEGIN:
  1097.     switch (strm->sm.sm_mode) {
  1098.     case smm_output:
  1099.     case smm_io:
  1100.     case smm_two_way:
  1101.     case smm_string_output:
  1102.         return(strm->sm.sm_int1);
  1103.  
  1104.     case smm_synonym:
  1105.         strm = symbol_value(strm->sm.sm_object0);
  1106.         if (type_of(strm) != t_stream)
  1107.             FEwrong_type_argument(Sstream, strm);
  1108.         goto BEGIN;
  1109.  
  1110.     case smm_echo:
  1111.         strm = strm->sm.sm_object1;
  1112.         goto BEGIN;
  1113.  
  1114.     case smm_input:
  1115.     case smm_probe:
  1116.     case smm_string_input:
  1117.         return(-1);
  1118.  
  1119.     case smm_concatenated:
  1120.         if (endp(strm->sm.sm_object0))
  1121.             return(-1);
  1122.         strm = strm->sm.sm_object0->c.c_car;
  1123.         goto BEGIN;
  1124.  
  1125.     case smm_broadcast:
  1126.         for (x = strm->sm.sm_object0; !endp(x); x = x->c.c_cdr) {
  1127.             i = file_column(x->c.c_car);
  1128.             if (i >= 0)
  1129.                 return(i);
  1130.         }
  1131.         return(-1);
  1132.  
  1133.     default:
  1134.         error("illegal stream mode");
  1135.     }
  1136. }
  1137.  
  1138. load(s)
  1139. char *s;
  1140. {
  1141.     object filename, strm, x;
  1142.     vs_mark;
  1143.  
  1144.     filename = make_simple_string(s);
  1145.     vs_push(filename);
  1146.     strm = open_stream(filename, smm_input, Cnil, Kerror);
  1147.     vs_push(strm);
  1148.     for (;;) {
  1149.         preserving_whitespace_flag = FALSE;
  1150.         detect_eos_flag = TRUE;
  1151.         x = read_object_non_recursive(strm);
  1152.         if (x == OBJNULL)
  1153.             break;
  1154.         vs_push(x);
  1155.         ieval(x);
  1156.         vs_pop;
  1157.     }
  1158.     close_stream(strm);
  1159.     vs_reset;
  1160. }
  1161.  
  1162. Lmake_synonym_stream()
  1163. {
  1164.     object x;
  1165.  
  1166.     check_arg(1);
  1167.     check_type_symbol(&vs_base[0]);
  1168.     x = alloc_object(t_stream);
  1169.     x->sm.sm_mode = (short)smm_synonym;
  1170.     x->sm.sm_fp = NULL;
  1171.     x->sm.sm_object0 = vs_base[0];
  1172.     x->sm.sm_object1 = OBJNULL;
  1173.     x->sm.sm_int0 = x->sm.sm_int1 = 0;
  1174.     vs_base[0] = x;
  1175. }
  1176.  
  1177. Lmake_broadcast_stream()
  1178. {
  1179.     object x;
  1180.     int narg, i;
  1181.  
  1182.     narg = vs_top - vs_base;
  1183.     for (i = 0;  i < narg;  i++)
  1184.         if (type_of(vs_base[i]) != t_stream ||
  1185.             !output_stream_p(vs_base[i]))
  1186.             cannot_write(vs_base[i]);
  1187.     vs_push(Cnil);
  1188.     for (i = narg;  i > 0;  --i)
  1189.         stack_cons();
  1190.     x = alloc_object(t_stream);
  1191.     x->sm.sm_mode = (short)smm_broadcast;
  1192.     x->sm.sm_fp = NULL;
  1193.     x->sm.sm_object0 = vs_base[0];
  1194.     x->sm.sm_object1 = OBJNULL;
  1195.     x->sm.sm_int0 = x->sm.sm_int1 = 0;
  1196.     vs_base[0] = x;
  1197. }
  1198.  
  1199. Lmake_concatenated_stream()
  1200. {
  1201.     object x;
  1202.     int narg, i;
  1203.  
  1204.     narg = vs_top - vs_base;
  1205.     for (i = 0;  i < narg;  i++)
  1206.         if (type_of(vs_base[i]) != t_stream ||
  1207.             !input_stream_p(vs_base[i]))
  1208.             cannot_read(vs_base[i]);
  1209.     vs_push(Cnil);
  1210.     for (i = narg;  i > 0;  --i)
  1211.         stack_cons();
  1212.     x = alloc_object(t_stream);
  1213.     x->sm.sm_mode = (short)smm_concatenated;
  1214.     x->sm.sm_fp = NULL;
  1215.     x->sm.sm_object0 = vs_base[0];
  1216.     x->sm.sm_object1 = OBJNULL;
  1217.     x->sm.sm_int0 = x->sm.sm_int1 = 0;
  1218.     vs_base[0] = x;
  1219. }
  1220.  
  1221. Lmake_two_way_stream()
  1222. {
  1223.     check_arg(2);
  1224.  
  1225.     if (type_of(vs_base[0]) != t_stream ||
  1226.         !input_stream_p(vs_base[0]))
  1227.         cannot_read(vs_base[0]);
  1228.     if (type_of(vs_base[1]) != t_stream ||
  1229.         !output_stream_p(vs_base[1]))
  1230.         cannot_write(vs_base[1]);
  1231.     vs_base[0] = make_two_way_stream(vs_base[0], vs_base[1]);
  1232.     vs_pop;
  1233. }
  1234.  
  1235. Lmake_echo_stream()
  1236. {
  1237.     check_arg(2);
  1238.  
  1239.     if (type_of(vs_base[0]) != t_stream ||
  1240.         !input_stream_p(vs_base[0]))
  1241.         cannot_read(vs_base[0]);
  1242.     if (type_of(vs_base[1]) != t_stream ||
  1243.         !output_stream_p(vs_base[1]))
  1244.         cannot_write(vs_base[1]);
  1245.     vs_base[0] = make_echo_stream(vs_base[0], vs_base[1]);
  1246.     vs_pop;
  1247. }
  1248.  
  1249. @(defun make_string_input_stream (strng &o istart iend)
  1250.     int s, e;
  1251. @
  1252.     check_type_string(&strng);
  1253.     if (istart == Cnil)
  1254.         s = 0;
  1255.     else if (type_of(istart) != t_fixnum)
  1256.         goto E;
  1257.     else
  1258.         s = fix(istart);
  1259.     if (iend == Cnil)
  1260.         e = strng->st.st_fillp;
  1261.     else if (type_of(iend) != t_fixnum)
  1262.         goto E;
  1263.     else
  1264.         e = fix(iend);
  1265.     if (s < 0 || e > strng->st.st_fillp || s > e)
  1266.         goto E;
  1267.     @(return `make_string_input_stream(strng, s, e)`)
  1268.  
  1269. E:
  1270.     FEerror("~S and ~S are illegal as :START and :END~%\
  1271. for the string ~S.",
  1272.         3, istart, iend, strng);
  1273. @)
  1274.  
  1275. Lmake_string_output_stream()
  1276. {
  1277.     check_arg(0);
  1278.     vs_push(make_string_output_stream(64));
  1279. }
  1280.  
  1281. Lget_output_stream_string()
  1282. {
  1283.     check_arg(1);
  1284.  
  1285.     if (type_of(vs_base[0]) != t_stream ||
  1286.         (enum smmode)vs_base[0]->sm.sm_mode != smm_string_output)
  1287.         FEerror("~S is not a string-output stream.", 1, vs_base[0]);
  1288.     vs_base[0] = get_output_stream_string(vs_base[0]);
  1289. }
  1290.  
  1291. /*
  1292.     (SI:OUTPUT-STREAM-STRING string-output-stream)
  1293.  
  1294.         extracts the string associated with the given
  1295.         string-output-stream.
  1296. */
  1297. siLoutput_stream_string()
  1298. {
  1299.     check_arg(1);
  1300.     if (type_of(vs_base[0]) != t_stream ||
  1301.         (enum smmode)vs_base[0]->sm.sm_mode != smm_string_output)
  1302.         FEerror("~S is not a string-output stream.", 1, vs_base[0]);
  1303.     vs_base[0] = vs_base[0]->sm.sm_object0;
  1304. }
  1305.  
  1306. Lstreamp()
  1307. {
  1308.     check_arg(1);
  1309.  
  1310.     if (type_of(vs_base[0]) == t_stream)
  1311.         vs_base[0] = Ct;
  1312.     else
  1313.         vs_base[0] = Cnil;
  1314. }
  1315.  
  1316. Linput_stream_p()
  1317. {
  1318.     check_arg(1);
  1319.  
  1320.     check_type_stream(&vs_base[0]);
  1321.     if (input_stream_p(vs_base[0]))
  1322.         vs_base[0] = Ct;
  1323.     else
  1324.         vs_base[0] = Cnil;
  1325. }
  1326.  
  1327. Loutput_stream_p()
  1328. {
  1329.     check_arg(1);
  1330.  
  1331.     check_type_stream(&vs_base[0]);
  1332.     if (output_stream_p(vs_base[0]))
  1333.         vs_base[0] = Ct;
  1334.     else
  1335.         vs_base[0] = Cnil;
  1336. }
  1337.  
  1338. Lstream_element_type()
  1339. {
  1340.     check_arg(1);
  1341.  
  1342.     check_type_stream(&vs_base[0]);
  1343.     vs_base[0] = stream_element_type(vs_base[0]);
  1344. }
  1345.  
  1346. @(defun close (strm &key abort)
  1347. @
  1348.     check_type_stream(&strm);
  1349.     close_stream(strm, abort != Cnil);
  1350.     @(return Ct)
  1351. @)
  1352.  
  1353. @(defun open (filename
  1354.           &key (direction Kinput)
  1355.            (element_type Sstring_char)
  1356.            (if_exists Cnil iesp)
  1357.            (if_does_not_exist Cnil idnesp)
  1358.           &aux strm)
  1359.     enum smmode smm;
  1360. @
  1361.     check_type_or_pathname_string_symbol_stream(&filename);
  1362.     filename = coerce_to_namestring(filename);
  1363.     if (direction == Kinput) {
  1364.         smm = smm_input;
  1365.         if (!idnesp)
  1366.             if_does_not_exist = Kerror;
  1367.     } else if (direction == Koutput) {
  1368.         smm = smm_output;
  1369.         if (!iesp)
  1370.             if_exists = Knew_version;
  1371.         if (!idnesp) {
  1372.             if (if_exists == Koverwrite ||
  1373.                 if_exists == Kappend)
  1374.                 if_does_not_exist = Kerror;
  1375.             else
  1376.                 if_does_not_exist = Kcreate;
  1377.         }
  1378.     } else if (direction == Kio) {
  1379.         smm = smm_io;
  1380.         if (!iesp)
  1381.             if_exists = Knew_version;
  1382.         if (!idnesp) {
  1383.             if (if_exists == Koverwrite ||
  1384.                 if_exists == Kappend)
  1385.                 if_does_not_exist = Kerror;
  1386.             else
  1387.                 if_does_not_exist = Kcreate;
  1388.         }
  1389.     } else if (direction == Kprobe) {
  1390.         smm = smm_probe;
  1391.         if (!idnesp)
  1392.             if_does_not_exist = Cnil;
  1393.     } else
  1394.         FEerror("~S is an illegal DIRECTION for OPEN.",
  1395.             1, direction);
  1396.     strm = open_stream(filename, smm, if_exists, if_does_not_exist);
  1397.     @(return strm)
  1398. @)
  1399.  
  1400. @(defun file_position (file_stream &o position)
  1401.     int i;
  1402. @
  1403.     check_type_stream(&file_stream);
  1404.     if (position == Cnil) {
  1405.         i = file_position(file_stream);
  1406.         if (i < 0)
  1407.             @(return Cnil)
  1408.         @(return `make_fixnum(i)`)
  1409.     } else {
  1410.         if (position == Kstart)
  1411.             i = 0;
  1412.         else if (position == Kend)
  1413.             i = file_length(file_stream);
  1414.         else if (type_of(position) != t_fixnum ||
  1415.             (i = fix((position))) < 0)
  1416.             FEerror("~S is an illegal file position~%\
  1417. for the file-stream ~S.",
  1418.                 2, position, file_stream);
  1419.         if (file_position_set(file_stream, i) < 0)
  1420.             @(return Cnil)
  1421.         @(return Ct)
  1422.     }    
  1423. @)
  1424.  
  1425. Lfile_length()
  1426. {
  1427.     int i;
  1428.  
  1429.     check_arg(1);
  1430.     check_type_stream(&vs_base[0]);
  1431.     i = file_length(vs_base[0]);
  1432.     if (i < 0)
  1433.         vs_base[0] = Cnil;
  1434.     else
  1435.         vs_base[0] = make_fixnum(i);
  1436. }
  1437.  
  1438. @(defun load (pathname
  1439.           &key (verbose `symbol_value(Vload_verbose)`)
  1440.             print
  1441.             (if_does_not_exist Kerror)
  1442.           &aux pntype fasl_filename lsp_filename filename
  1443.            defaults strm stdoutput x
  1444.            package)
  1445.     bds_ptr old_bds_top;
  1446.     int i;
  1447.     object strm1;
  1448. @
  1449.     check_type_or_pathname_string_symbol_stream(&pathname);
  1450.     pathname = coerce_to_pathname(pathname);
  1451.     defaults = symbol_value(Vdefault_pathname_defaults);
  1452.     defaults = coerce_to_pathname(defaults);
  1453.     pathname = merge_pathnames(pathname, defaults, Knewest);
  1454.     pntype = pathname->pn.pn_type;
  1455.     filename = coerce_to_namestring(pathname);
  1456.     if (pntype == Cnil || pntype == Kwild ||
  1457.         type_of(pntype) == t_string &&
  1458. #ifdef UNIX
  1459.         string_eq(pntype, FASL_string)) {
  1460. #endif
  1461. #ifdef AOSVS
  1462.  
  1463. #endif
  1464.         pathname->pn.pn_type = FASL_string;
  1465.         fasl_filename = coerce_to_namestring(pathname);
  1466.     }
  1467.     if (pntype == Cnil || pntype == Kwild ||
  1468.         type_of(pntype) == t_string &&
  1469. #ifdef UNIX
  1470.         string_eq(pntype, LSP_string)) {
  1471. #endif
  1472. #ifdef AOSVS
  1473.  
  1474. #endif
  1475.         pathname->pn.pn_type = LSP_string;
  1476.         lsp_filename = coerce_to_namestring(pathname);
  1477.     }
  1478.     if (fasl_filename != Cnil && file_exists(fasl_filename)) {
  1479.         if (verbose != Cnil) {
  1480.             setupPRINTdefault(fasl_filename);
  1481.             if (file_column(PRINTstream) != 0)
  1482.                 write_str("\n");
  1483.             write_str("Loading ");
  1484.             PRINTescape = FALSE;
  1485.             write_object(fasl_filename, 0);
  1486.             write_str("\n");
  1487.             cleanupPRINT();
  1488.             flush_stream(PRINTstream);
  1489.         }
  1490.         package = symbol_value(Vpackage);
  1491.         old_bds_top = bds_top;
  1492.         bds_bind(Vpackage, package);
  1493.         i = fasload(fasl_filename);
  1494.         if (print != Cnil) {
  1495.             setupPRINTdefault(Cnil);
  1496.             vs_top = PRINTvs_top;
  1497.             if (file_column(PRINTstream) != 0)
  1498.                 write_str("\n");
  1499.             write_str("Fasload successfully ended.");
  1500.             write_str("\n");
  1501.             cleanupPRINT();
  1502.             flush_stream(PRINTstream);
  1503.         }
  1504.         bds_unwind(old_bds_top);
  1505.         if (verbose != Cnil) {
  1506.             setupPRINTdefault(fasl_filename);
  1507.             if (file_column(PRINTstream) != 0)
  1508.                 write_str("\n");
  1509.             write_str("Finished loading ");
  1510.             PRINTescape = FALSE;
  1511.             write_object(fasl_filename, 0);
  1512.             write_str("\n");
  1513.             cleanupPRINT();
  1514.             flush_stream(PRINTstream);
  1515.         }
  1516.         @(return `make_fixnum(i)`)
  1517.     }
  1518.     if (lsp_filename != Cnil && file_exists(lsp_filename)) {
  1519.         filename = lsp_filename;
  1520.     }
  1521.     if (if_does_not_exist != Cnil)
  1522.         if_does_not_exist = Kerror;
  1523.     strm1 = strm
  1524.     = open_stream(filename, smm_input, Cnil, if_does_not_exist);
  1525.     if (strm == Cnil)
  1526.         @(return Cnil)
  1527.     if (verbose != Cnil) {
  1528.         setupPRINTdefault(filename);
  1529.         if (file_column(PRINTstream) != 0)
  1530.             write_str("\n");
  1531.         write_str("Loading ");
  1532.         PRINTescape = FALSE;
  1533.         write_object(filename, 0);
  1534.         write_str("\n");
  1535.         cleanupPRINT();
  1536.         flush_stream(PRINTstream);
  1537.     }
  1538.     package = symbol_value(Vpackage);
  1539.     old_bds_top = bds_top;
  1540.     bds_bind(Vpackage, package);
  1541.     bds_bind(Vstandard_input, strm);
  1542.     frs_push(FRS_PROTECT, Cnil);
  1543.     if (nlj_active) {
  1544.         close_stream(strm1, TRUE);
  1545.         nlj_active = FALSE;
  1546.         frs_pop();
  1547.         bds_unwind(old_bds_top);
  1548.         unwind(nlj_fr, nlj_tag);
  1549.     }
  1550.     for (;;) {
  1551.         preserving_whitespace_flag = FALSE;
  1552.         detect_eos_flag = TRUE;
  1553.         x = read_object_non_recursive(strm);
  1554.         if (x == OBJNULL)
  1555.             break;
  1556.         {
  1557.             object *base = vs_base, *top = vs_top, *lex = lex_env;
  1558.             object xx;
  1559.  
  1560.             lex_new();
  1561.             eval(x);
  1562.             xx = vs_base[0];
  1563.             lex_env = lex;
  1564.             vs_top = top;
  1565.             vs_base = base;
  1566.             x = xx;
  1567.         }
  1568.         if (print != Cnil) {
  1569.             setupPRINTdefault(x);
  1570.             write_object(x, 0);
  1571.             write_str("\n");
  1572.             cleanupPRINT();
  1573.             flush_stream(PRINTstream);
  1574.         }
  1575.     }
  1576.     close_stream(strm, TRUE);
  1577.     frs_pop();
  1578.     bds_unwind(old_bds_top);
  1579.     if (verbose != Cnil) {
  1580.         setupPRINTdefault(filename);
  1581.         if (file_column(PRINTstream) != 0)
  1582.             write_str("\n");
  1583.         write_str("Finished loading ");
  1584.         PRINTescape = FALSE;
  1585.         write_object(filename, 0);
  1586.         write_str("\n");
  1587.         cleanupPRINT();
  1588.         flush_stream(PRINTstream);
  1589.     }
  1590.     @(return Ct)
  1591. @)
  1592.  
  1593. siLget_string_input_stream_index()
  1594. {
  1595.     check_arg(1);
  1596.     check_type_stream(&vs_base[0]);
  1597.     if ((enum smmode)vs_base[0]->sm.sm_mode != smm_string_input)
  1598.         FEerror("~S is not a string-input stream.", 1, vs_base[0]);
  1599.     vs_base[0] = make_fixnum(vs_base[0]->sm.sm_int0);
  1600. }
  1601.  
  1602. siLmake_string_output_stream_from_string()
  1603. {
  1604.     object strng, strm;
  1605.  
  1606.     check_arg(1);
  1607.     strng = vs_base[0];
  1608.     if (type_of(strng) != t_string || !strng->st.st_hasfillp)
  1609.         FEerror("~S is not a string with a fill-pointer.", 1, strng);
  1610.     strm = alloc_object(t_stream);
  1611.     strm->sm.sm_mode = (short)smm_string_output;
  1612.     strm->sm.sm_fp = NULL;
  1613.     strm->sm.sm_object0 = strng;
  1614.     strm->sm.sm_object1 = OBJNULL;
  1615.     strm->sm.sm_int0 = strng->st.st_fillp;
  1616.     strm->sm.sm_int1 = 0;
  1617.     vs_base[0] = strm;
  1618. }
  1619.  
  1620. siLcopy_stream()
  1621. {
  1622.     object in, out;
  1623.  
  1624.     check_arg(2);
  1625.     check_type_stream(&vs_base[0]);
  1626.     check_type_stream(&vs_base[1]);
  1627.     in = vs_base[0];
  1628.     out = vs_base[1];
  1629.     while (!stream_at_end(in))
  1630.         writec_stream(readc_stream(in), out);
  1631.     flush_stream(out);
  1632.     vs_base[0] = Ct;
  1633.     vs_pop;
  1634. #ifdef AOSVS
  1635.  
  1636. #endif
  1637. }
  1638.  
  1639.  
  1640. too_long_file_name(fn)
  1641. object fn;
  1642. {
  1643.     FEerror("~S is a too long file name.", 1, fn);
  1644. }
  1645.  
  1646. cannot_open(fn)
  1647. object fn;
  1648. {
  1649.     FEerror("Cannot open the file ~A.", 1, fn);
  1650. }
  1651.  
  1652. cannot_create(fn)
  1653. object fn;
  1654. {
  1655.     FEerror("Cannot create the file ~A.", 1, fn);
  1656. }
  1657.  
  1658. cannot_read(strm)
  1659. object strm;
  1660. {
  1661.     FEerror("Cannot read the stream ~S.", 1, strm);
  1662. }
  1663.  
  1664. cannot_write(strm)
  1665. object strm;
  1666. {
  1667.     FEerror("Cannot write to the stream ~S.", 1, strm);
  1668. }
  1669.  
  1670. closed_stream(strm)
  1671. object strm;
  1672. {
  1673.     FEerror("The stream ~S is already closed.", 1, strm);
  1674. }
  1675.  
  1676.  
  1677. init_file()
  1678. {
  1679.     object standard_input;
  1680.     object standard_output;
  1681.     object standard;
  1682.     object x;
  1683. #ifdef AOSVS1
  1684.  
  1685.  
  1686.  
  1687. #endif
  1688.  
  1689.     standard_input = alloc_object(t_stream);
  1690.     standard_input->sm.sm_mode = (short)smm_input;
  1691.     standard_input->sm.sm_fp = stdin;
  1692.     standard_input->sm.sm_object0 = Sstring_char;
  1693.     standard_input->sm.sm_object1
  1694. #ifdef UNIX
  1695.     = make_simple_string("stdin");
  1696. #endif
  1697. #ifdef AOSVS
  1698.  
  1699. #endif
  1700.     standard_input->sm.sm_int0 = 0;
  1701.     standard_input->sm.sm_int1 = 0;
  1702.  
  1703.     standard_output = alloc_object(t_stream);
  1704.     standard_output->sm.sm_mode = (short)smm_output;
  1705.     standard_output->sm.sm_fp = stdout;
  1706.     standard_output->sm.sm_object0 = Sstring_char;
  1707.     standard_output->sm.sm_object1
  1708. #ifdef UNIX
  1709.     = make_simple_string("stdout");
  1710. #endif
  1711. #ifdef AOSVS
  1712.  
  1713. #endif
  1714.     standard_output->sm.sm_int0 = 0;
  1715.     standard_output->sm.sm_int1 = 0;
  1716.  
  1717.     terminal_io = standard
  1718.     = make_two_way_stream(standard_input, standard_output);
  1719.     enter_mark_origin(&terminal_io);
  1720.  
  1721.     Vterminal_io
  1722.     = make_special("*TERMINAL-IO*", standard);
  1723.  
  1724.     x = alloc_object(t_stream);
  1725.     x->sm.sm_mode = (short)smm_synonym;
  1726.     x->sm.sm_fp = NULL;
  1727.     x->sm.sm_object0 = Vterminal_io;
  1728.     x->sm.sm_object1 = OBJNULL;
  1729.     x->sm.sm_int0 = x->sm.sm_int1 = 0;
  1730.     standard = x;
  1731.  
  1732.     Vstandard_input
  1733.     = make_special("*STANDARD-INPUT*", standard);
  1734.     Vstandard_output
  1735.     = make_special("*STANDARD-OUTPUT*", standard);
  1736.     Verror_output
  1737.     = make_special("*ERROR-OUTPUT*", standard);
  1738.  
  1739. #ifdef AOSVS1
  1740.  
  1741.  
  1742.  
  1743.  
  1744.  
  1745.  
  1746.  
  1747.  
  1748.  
  1749.  
  1750.  
  1751.  
  1752.  
  1753.  
  1754. #endif
  1755.  
  1756.     Vquery_io
  1757.     = make_special("*QUERY-IO*", standard);
  1758.     Vdebug_io
  1759.     = make_special("*DEBUG-IO*", standard);
  1760.     Vtrace_output
  1761.     = make_special("*TRACE-OUTPUT*", standard);
  1762.  
  1763. #ifdef AOSVS1
  1764.  
  1765.  
  1766.  
  1767.  
  1768.  
  1769.  
  1770.  
  1771.  
  1772.  
  1773.  
  1774.  
  1775.  
  1776.  
  1777.  
  1778.  
  1779.  
  1780.  
  1781.  
  1782.  
  1783. #endif
  1784. }
  1785.  
  1786. init_file_function()
  1787. {
  1788.     Kabort = make_keyword("ABORT");
  1789.  
  1790.     Kdirection = make_keyword("DIRECTION");
  1791.     Kinput = make_keyword("INPUT");
  1792.     Koutput = make_keyword("OUTPUT");
  1793.     Kio = make_keyword("IO");
  1794.     Kprobe = make_keyword("PROBE");
  1795.     Kelement_type = make_keyword("ELEMENT-TYPE");
  1796.     Kdefault = make_keyword("DEFAULT");
  1797.     Kif_exists = make_keyword("IF-EXISTS");
  1798.     Kerror = make_keyword("ERROR");
  1799.     Knew_version = make_keyword("NEW-VERSION");
  1800.     Krename = make_keyword("RENAME");
  1801.     Krename_and_delete = make_keyword("RENAME-AND-DELETE");
  1802.     Koverwrite = make_keyword("OVERWRITE");
  1803.     Kappend = make_keyword("APPEND");
  1804.     Ksupersede = make_keyword("SUPERSEDE");
  1805.     Kif_does_not_exist = make_keyword("IF-DOES-NOT-EXIST");
  1806.     /*  Kerror = make_keyword("ERROR");  */
  1807.     Kcreate = make_keyword("CREATE");
  1808.  
  1809.     Kprint = make_keyword("PRINT");
  1810.     Kverbose = make_keyword("VERBOSE");
  1811.     Kif_does_not_exist = make_keyword("IF-DOES-NOT-EXIST");
  1812.     Kset_default_pathname = make_keyword("SET-DEFAULT-PATHNAME");
  1813.  
  1814.     Vload_verbose = make_special("*LOAD-VERBOSE*", Ct);
  1815.  
  1816. #ifdef UNIX
  1817.     FASL_string = make_simple_string("o");
  1818. #endif
  1819. #ifdef AOSVS
  1820.  
  1821. #endif
  1822.     enter_mark_origin(&FASL_string);
  1823. #ifdef UNIX
  1824.     LSP_string = make_simple_string("lsp");
  1825. #endif
  1826. #ifdef AOSVS
  1827.  
  1828. #endif
  1829.     enter_mark_origin(&LSP_string);
  1830.  
  1831.     make_function("MAKE-SYNONYM-STREAM", Lmake_synonym_stream);
  1832.     make_function("MAKE-BROADCAST-STREAM", Lmake_broadcast_stream);
  1833.     make_function("MAKE-CONCATENATED-STREAM",
  1834.               Lmake_concatenated_stream);
  1835.     make_function("MAKE-TWO-WAY-STREAM", Lmake_two_way_stream);
  1836.     make_function("MAKE-ECHO-STREAM", Lmake_echo_stream);
  1837.     make_function("MAKE-STRING-INPUT-STREAM",
  1838.               Lmake_string_input_stream);
  1839.     make_function("MAKE-STRING-OUTPUT-STREAM",
  1840.               Lmake_string_output_stream);
  1841.     make_function("GET-OUTPUT-STREAM-STRING",
  1842.               Lget_output_stream_string);
  1843.  
  1844.     make_si_function("OUTPUT-STREAM-STRING", siLoutput_stream_string);
  1845.  
  1846.     make_function("STREAMP", Lstreamp);
  1847.     make_function("INPUT-STREAM-P", Linput_stream_p);
  1848.     make_function("OUTPUT-STREAM-P", Loutput_stream_p);
  1849.     make_function("STREAM-ELEMENT-TYPE", Lstream_element_type);
  1850.     make_function("CLOSE", Lclose);
  1851.  
  1852.     make_function("OPEN", Lopen);
  1853.  
  1854.     make_function("FILE-POSITION", Lfile_position);
  1855.     make_function("FILE-LENGTH", Lfile_length);
  1856.  
  1857.     make_function("LOAD", Lload);
  1858.  
  1859.     make_si_function("GET-STRING-INPUT-STREAM-INDEX",
  1860.              siLget_string_input_stream_index);
  1861.     make_si_function("MAKE-STRING-OUTPUT-STREAM-FROM-STRING",
  1862.              siLmake_string_output_stream_from_string);
  1863.     make_si_function("COPY-STREAM", siLcopy_stream);
  1864.  
  1865.     siVignore_eof_on_terminal_io
  1866.     = make_si_special("*IGNORE-EOF-ON-TERMINAL-IO*", Cnil);
  1867. }
  1868.  
  1869.  
  1870. object
  1871. read_fasl_data(str)
  1872. char *str;
  1873. {
  1874.     object faslfile, data;
  1875. #ifdef UNIX
  1876.     FILE *fp;
  1877. #ifdef BSD
  1878.     struct exec header;
  1879. #endif
  1880. #ifdef ATT
  1881.     struct filehdr fileheader;
  1882. #endif
  1883. #ifdef E15
  1884.     struct exec header;
  1885. #endif
  1886.     int i;
  1887. #endif
  1888.         vs_mark;
  1889.  
  1890.     faslfile = make_simple_string(str);
  1891.     vs_push(faslfile);
  1892.     faslfile = open_stream(faslfile, smm_input, Cnil, Kerror);
  1893.     vs_push(faslfile);
  1894.  
  1895. #ifdef BSD
  1896.     fp = faslfile->sm.sm_fp;
  1897.     fread(&header, sizeof(header), 1, fp);
  1898.     fseek(fp,
  1899.           header.a_text+header.a_data+
  1900.           header.a_syms+header.a_trsize+header.a_drsize,
  1901.           1);
  1902.     fread(&i, sizeof(i), 1, fp);
  1903.     fseek(fp, i - sizeof(i), 1);
  1904. #endif
  1905.  
  1906. #ifdef ATT
  1907.     fp = faslfile->sm.sm_fp;
  1908.     fread(&fileheader, sizeof(fileheader), 1, fp);
  1909.     fseek(fp,
  1910.           fileheader.f_symptr+fileheader.f_nsyms*SYMESZ,
  1911.           0);
  1912.     fread(&i, sizeof(i), 1, fp);
  1913.     fseek(fp, i - sizeof(i), 1);
  1914.     while ((i = getc(fp)) == 0)
  1915.         ;
  1916.     ungetc(i, fp);
  1917. #endif
  1918.  
  1919. #ifdef E15
  1920.     fp = faslfile->sm.sm_fp;
  1921.     fread(&header, sizeof(header), 1, fp);
  1922.     fseek(fp,
  1923.           header.a_text+header.a_data+
  1924.           header.a_syms+header.a_trsize+header.a_drsize,
  1925.           1);
  1926. #endif
  1927.  
  1928. #ifdef DGUX
  1929.  
  1930.  
  1931.  
  1932.  
  1933. #endif
  1934.  
  1935. #ifdef AOSVS
  1936.  
  1937.  
  1938.  
  1939.  
  1940. #endif
  1941.  
  1942.     data = read_fasl_vector(faslfile);
  1943.  
  1944.     vs_push(data);
  1945.     close_stream(faslfile, TRUE);
  1946.     vs_reset;
  1947.     return(data);
  1948. }
  1949.